home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / bitmap-br.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-05  |  3.1 KB  |  87 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         bitmap-br.lsp
  5. ; RCS:          $Header: bitmap-br.lsp,v 1.3 91/10/05 05:14:17 mayer Exp $
  6. ; Description:  Given a directory of X11 bitmaps at location
  7. ;               <bitmap_directory_path>, the function 
  8. ;                      (BROWSE-BITMAP-DIRECTORY <bitmap_directory_path>)
  9. ;               will put up a browser that will allow you to change your root
  10. ;               pixmap pattern by clicking on a bitmap image in the browser.
  11. ; Author:       Niels Mayer, HPLabs
  12. ; Created:      Sat Nov 25 00:53:06 1989
  13. ; Modified:     Sat Oct  5 05:13:37 1991 (Niels Mayer) mayer@hplnpm
  14. ; Language:     Lisp
  15. ; Package:      N/A
  16. ; Status:       X11r5 contrib tape release
  17. ;
  18. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  19. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  20. ;
  21. ; Permission to use, copy, modify, distribute, and sell this software and its
  22. ; documentation for any purpose is hereby granted without fee, provided that
  23. ; the above copyright notice appear in all copies and that both that
  24. ; copyright notice and this permission notice appear in supporting
  25. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  26. ; used in advertising or publicity pertaining to distribution of the software
  27. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  28. ; makes no representations about the suitability of this software for any
  29. ; purpose.  It is provided "as is" without express or implied warranty.
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. (defun browse-bitmap-directory (dir)
  33.   (let* (
  34.      (top_w (send TOP_LEVEL_SHELL_WIDGET_CLASS :new "bmbrshl"
  35.               :XMN_GEOMETRY    "=360x720+0+0"
  36.               :XMN_TITLE    (strcat "Bitmap browser: " dir)
  37.               :XMN_ICON_NAME    (strcat "Bitmaps[" dir "]")
  38.               ))
  39.      (sc_w (send XM_SCROLLED_WINDOW_WIDGET_CLASS :new :managed
  40.              "sc" top_w
  41.              :XMN_SCROLLING_POLICY :AUTOMATIC
  42.              ))
  43.      (rc_w (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed
  44.              "rc" sc_w
  45.              :XMN_ORIENTATION        :vertical
  46.              :XMN_PACKING        :pack_tight
  47.              :XMN_ENTRY_ALIGNMENT    :alignment_center
  48. ;;;             :XMN_FOREGROUND        "Black"
  49. ;;;             :XMN_BACKGROUND        "LightGray"
  50.              ))
  51.      )
  52.     (do* 
  53.      ((fp (popen (strcat "/bin/ls " dir) :direction :input))
  54.       (name (read-line fp) (read-line fp))
  55.       bitmap-file
  56.       )
  57.      ((null name)
  58.       (pclose fp)
  59.       (send top_w :realize)
  60.       )
  61.      (setq bitmap-file (strcat dir "/" name))
  62.      (format T "name=~A\n" name)
  63.      (send XM_LABEL_GADGET_CLASS :new :managed
  64.        "filename" rc_w
  65.        :XMN_LABEL_TYPE    :string
  66.        :XMN_LABEL_STRING    name
  67.        )
  68.      (send
  69.       (send XM_PUSH_BUTTON_GADGET_CLASS :new :managed
  70.         "image" rc_w
  71.         :XMN_LABEL_TYPE    :pixmap
  72.         :XMN_LABEL_PIXMAP    bitmap-file
  73.         )
  74.       :add_callback :XMN_ACTIVATE_CALLBACK '()
  75.       `((xsetroot ,bitmap-file))
  76.       )
  77.      (send XM_SEPARATOR_GADGET_CLASS :new :managed
  78.        "sep" rc_w
  79.        :XMN_SEPARATOR_TYPE :DOUBLE_LINE
  80.        )
  81.      )
  82.     )
  83.   )
  84.  
  85. (defun xsetroot (filename)
  86.   (system (format nil "xsetroot -bitmap ~A -fg Black -bg DimGrey" filename)))
  87.